Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/vbcons1a/frmconso.frm

Visual Basic Form | 1999-09-24 | 10.0 KB | 263 lines

VERSION 5.00
Begin VB.Form frmConsole
   BackColor       =   &H80000004&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "VBConsole"
   ClientHeight    =   6630
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   10290
   BeginProperty Font
      Name            =   "Fixedsys"
      Size            =   9
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6630
   ScaleWidth      =   10290
   StartUpPosition =   3  'Windows Default
   Begin VB.PictureBox picConsole
      Align           =   1  'Align Top
      Height          =   6825
      Left            =   0
      ScaleHeight     =   6765
      ScaleWidth      =   10230
      TabIndex        =   0
      Top             =   0
      Width           =   10290
      Begin VB.CommandButton cmdMin
         Caption         =   "<"
         Height          =   225
         Left            =   9450
         TabIndex        =   2
         Top             =   6330
         Width           =   255
      End
      Begin VB.ListBox lstConsole
         BackColor       =   &H00008080&
         ForeColor       =   &H00C0FFFF&
         Height          =   6585
         ItemData        =   "frmConsole.frx":0000
         Left            =   0
         List            =   "frmConsole.frx":0007
         MousePointer    =   3  'I-Beam
         TabIndex        =   4
         Top             =   0
         Width           =   9975
      End
      Begin VB.CommandButton cmdColorCycle
         Caption         =   "COLOR"
         Height          =   1575
         Left            =   9960
         TabIndex        =   3
         Top             =   0
         Width           =   255
      End
      Begin VB.CommandButton cmdCLS
         Caption         =   "CLEAR"
         Height          =   1215
         Left            =   9960
         TabIndex        =   1
         Top             =   5400
         Width           =   255
      End
   End
Attribute VB_Name = "frmConsole"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'The Simple to use VB Console
'Author: Zane Horton
'Company: Camelback Research Alliance
'This is the console form. You can add it to any project with just this form.
'All of the code for it is self contained, and it uses no API calls or special controls.
'All output to this console is placed on its own line.
'If you write a string longer then the standard width of the console
'(as declared by intConsoleTextWidth), it will hard wrap it (I.E. it breaks
'words between lines).
'To output a line to the console, do this (from another form):
'frmconsole.cout("Some string with a user value of :" + MyUserValue)
'You can clear the Console with frmConsole.cmdCLS_Click
'You can cycle the colors with frmConsole.cmdColorCycle_Click
'You can scroll the console with the following sub calls (self explanatory)
'frmConsole.ScrollToBeginning
'frmConsole.ScrollUp
'frmConsole.ScrollDown
'frmConsole.ScrollToEnd
'You can also toggle the Console tools with frmConsole.cmdMin_Click
'Note - You can add all the text to the console you want while it's hidden,
'But don't try to scroll the console while it's hidden - it's just extra CPU
'Time wasted (since I made it robust enough to not die when you try that)
'Yes I know that the text box could be used, but I liked the list box's usability
'much better (the text box is just too annoying since you can't tell it not to
'auto-wrap the text, which screwed up all my calculations...)
'Note - Clear the console every once in a while, since you can only have up to
'32000 lines. (After that it goes on a coffee break and ignores you trying to
'add lines...)
'If you want to output the contents of the console to a file, do:
'frmConsole.SaveContents(strFileName)
Const intConsoleTextWidth As Integer = 80
Const intConsoleWidthMin As Integer = 10110
Const intConsoleWidthMax As Integer = 10380
Const NumOfColorSchemes As Byte = 5
Const ForceRefresh As Boolean = True
Dim CurrentColorScheme As Byte
Dim ConsoleBackColor(1 To NumOfColorSchemes) As Variant
Dim ConsoleForeColor(1 To NumOfColorSchemes) As Variant
Dim FormSmall As Boolean
Dim i, j As Integer
Option Explicit
Sub cmdCLS_Click()
    lstConsole.Clear
End Sub
Sub cmdColorCycle_Click()
    If CurrentColorScheme = NumOfColorSchemes Then
        CurrentColorScheme = 1
      Else
        CurrentColorScheme = CurrentColorScheme + 1
    End If
    lstConsole.BackColor = ConsoleBackColor(CurrentColorScheme)
    lstConsole.ForeColor = ConsoleForeColor(CurrentColorScheme)
    'This is optional
    'Cout ("Current color scheme number " + Format(CurrentColorScheme))
End Sub
Sub cmdMin_Click()
    If FormSmall Then
        For i = intConsoleWidthMin To intConsoleWidthMax
            frmConsole.Width = i
        Next i
        FormSmall = False
        cmdMin.Caption = "<"
      Else
        For i = intConsoleWidthMax To intConsoleWidthMin Step -1
            frmConsole.Width = i
        Next i
        FormSmall = True
        cmdMin.Caption = ">"
    End If
End Sub
Private Sub Form_Load()
    lstConsole.Clear
    FormSmall = False
    CurrentColorScheme = 0
    'If you want to add more color schemes, go right ahead!
    'Just make sure to change the constant up top called
    'NumOfColorSchemes. You can have up to 255 color schemes!
    'If you're daring, make a RANDOM color scheme like this:
    'ConsoleBackColor(6) = rgb((int(rnd(1)*254)+1),(int(rnd(1)*254)+1),(int(rnd(1)*254)+1))
    'ConsoleForeColor(6) = rgb((int(rnd(1)*254)+1),(int(rnd(1)*254)+1),(int(rnd(1)*254)+1))
    'White text on black
    ConsoleBackColor(1) = vbBlack
    ConsoleForeColor(1) = vbWhite
    'Black text on White
    ConsoleBackColor(2) = vbWhite
    ConsoleForeColor(2) = vbBlack
    'Monochrome style
    ConsoleBackColor(3) = vbBlack
    'ConsoleBackColor(3) = &H8000&   'An alternate for light green text on dark green
    ConsoleForeColor(3) = &HFF00&
    'Amber style
    ConsoleBackColor(4) = vbBlack
    'ConsoleBackColor(4) = &H8080&   'An alternate for light Amber text on dark Amber
    ConsoleForeColor(4) = &HC0FFFF
    'Commodore style
    ConsoleBackColor(5) = &HFF0000
    ConsoleForeColor(5) = &HFFFF00
    'Random  :)
    'ConsoleBackColor(6) = RGB((Int(Rnd(1) * 254) + 1), (Int(Rnd(1) * 254) + 1), (Int(Rnd(1) * 254) + 1))
    'ConsoleForeColor(6) = RGB((Int(Rnd(1) * 254) + 1), (Int(Rnd(1) * 254) + 1), (Int(Rnd(1) * 254) + 1))
    Call cmdColorCycle_Click
End Sub
Sub Cout(text As String)
    Dim TextLength As Integer
    Dim LastLineLen As Integer
    Dim NumLines As Byte
    Dim k As Byte
    If lstConsole.ListCount > 32000 Then
        Exit Sub
    End If
    TextLength = Len(text)
    If TextLength <= intConsoleTextWidth Then
        'This string is less than the normal line size, so just add it.
        lstConsole.AddItem text
      Else
        'This string is greater than the normal line size, so make sure it displays properly.

        'Set the length of the last line's text
        LastLineLen = TextLength Mod intConsoleTextWidth
        'Set the number of full lines to output
        NumLines = Int(TextLength / intConsoleTextWidth)
        'Output each line (except the partial last line if applicable
        For k = 1 To NumLines
            lstConsole.AddItem Mid$(text, (((k - 1) * intConsoleTextWidth) + 1), intConsoleTextWidth)
        Next k
        'Output the last line (if applicable)
        If LastLineLen > 0 Then lstConsole.AddItem Right(text, LastLineLen)
    End If
    If ForceRefresh Then lstConsole.Refresh
End Sub
Private Sub lstConsole_DblClick()
    Clipboard.SetText lstConsole.List(lstConsole.ListIndex)
End Sub
Sub ScrollDown()
    'OK, so I cheated, but hey, It works!
    lstConsole.SetFocus
    SendKeys "{DOWN}"   'Send the DOWN arrow key to the list
End Sub
Sub ScrollUp()
    lstConsole.SetFocus
    SendKeys "{UP}"     'Send the UP arrow key to the list
End Sub
Sub ScrollToEnd()
    lstConsole.SetFocus
    SendKeys "^{END}"   'Send the CTRL + END keys to the list
End Sub
Sub ScrollToBeginning()
    lstConsole.SetFocus
    SendKeys "^{HOME}"  'Send the CTRL + HOME keys to the list
End Sub
Sub SaveContents(strFileName As String)
    'This function will output the console's contents (if there are any) to a
    'Text file as specified in the passed string.
    Dim ListLine As Integer
    Dim FreeFileNum As Byte
    On Error GoTo BadSave
    'Validate the file name that got passed
    If Mid(strFileName, 2, 2) <> ":\" Then
        MsgBox$ ("Please Enter a valid filename, Like C:\ConsoleOutput.txt")
        Exit Sub
    End If
    'Make sure there are some contents to save first
    If lstConsole.ListCount = 0 Then
        MsgBox$ ("Please wait until there is output before you try to save it.")
        Exit Sub
    End If
    'Now we Actually save the file
    'Get a free file number
    FreeFileNum = FreeFile
    'Open the file
    Open strFileName For Output As #FreeFileNum
    'Loop for each list line
    For ListLine = 1 To lstConsole.ListCount
        Print #FreeFileNum, lstConsole.List(ListLine)
    Next ListLine
    'Close the file
    Close #FreeFileNum
    'I always like to close all the open files just in case :)
    Close
    'Tell the user that it's all A-OK.
    MsgBox$ ("The Contents have been saved to " + strFileName + ".")
    'Exit to make sure we don't tell the user it errored after it saved OK :)
    Exit Sub
BadSave:
    'Uh-Oh, something happened
    MsgBox$ ("There was an error saving the contents to " + strFileName + ".")
End Sub